home *** CD-ROM | disk | FTP | other *** search
/ User's Choice Windows CD / User's Choice Windows CD (CMS Software)(1993).iso / utility3 / swtools.zip / SWDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-09  |  11KB  |  324 lines
  1. program SWToolsDemo;
  2.  
  3. {ShareWare Tools  (c) 1992 Scott Gifford.  All Rights Reserved.}
  4.  
  5.  
  6. {This program was written in Turbo Pascal for Windows V1.5.  I have tried
  7.  my best, however, to make it understandable for programmers in all languages
  8.  with my comments.  If you still don't understand something, or if you have
  9.  any type of question about this program, please contact me at one of the
  10.  addresses listed under Questions, Problems, and Comments in the SWTools.HLP
  11.  file.}
  12.  
  13.                  {Thank you for trying SWTools!}
  14.  
  15.                                                 {---Scott.}
  16.  
  17.  
  18.   {The following command causes a resource file to be included.}
  19. {$r swdemo}
  20.  
  21.   {These units are included in most Windows applications}
  22. uses WObjects,WinTypes,WinProcs,Strings,WinCRT;
  23.  
  24. const
  25.   pw:array[0..8] of char='password';                 {program password}
  26.   TrialPeriod=30;                                    {Length of trial period}
  27.   RegPath:packed array[0..15] of char='swdemo.reg';  {Registration file}
  28.   DGBPath:packed array[0..15] of char='swdemo.dgb';  {DateStamp file}
  29.  
  30.   id_register=110;                                   {A button in the DBs}
  31.   id_proceed=111;                                    {Another button}
  32.   id_quit=112;                                       {Yet another button}
  33.   id_DaysLeft=121;                                   {A static from a DB}
  34.   id_name=101;                                       {Edit control ID}
  35.   id_reg=102;                                        {  "     "     "}
  36.   id_quest=103;                                      {  "     "     "}
  37.   id_FavColor=104;                                   {  "     "     "}
  38.  
  39.   id_scram=120;                         {Scramble button}    
  40.   id_date=121;                                       {MakeDate button}
  41.   id_help=122;                                       {help button}
  42.   id_QuestBtn=123;                                   {quest button}
  43.   id_FavColorBtn=124;                                {favorite coloe button}
  44.  
  45. type
  46.   Str10=array[0..10] of char;     {TPW treats these arrays as pointers to
  47.                                     null-terminated strings}
  48.  
  49. var {global}
  50.   Registered:integer;             {1 if registered}
  51.   Name,                           {Registration name}
  52.   Quest,                          {Reg. quest}
  53.   FavColor:Str10;                 {Reg. Favorite color}
  54.   
  55.  
  56.  
  57. {Importing the DLL.  If you don't speak TPW fluently, note that PChar
  58.  refers to a null-terminated string and PDosStream to a pointer to
  59.  a DOS stream.  If your language doesn't support either of these, just
  60.  use a plain old pointer.}
  61.  
  62. procedure scramble(what,password,result:PChar;v:integer);
  63.   far; external 'SWTOOLS1' index 1;
  64. function CreateDateFile(FileName,password:PChar;v:integer):integer;
  65.   far; external 'SWTOOLS1' index 2;
  66. function CreateNewDate(FileName,pw:PChar; v:integer):integer;
  67.   far; external 'SWTOOLS1' index 3;
  68. function DaysGoneBy(FileName,password:PChar;v:integer):integer;
  69.   far; external 'SWTOOLS1' index 4;
  70. function CheckRegistration(RegFile,Name,PassWord:PChar; more:integer;
  71.  var MoreToFollow:PDosStream;v:integer):integer;
  72.   far; external 'SWTOOLS1' index 5;
  73. procedure GetRegInfo(MoreFollowing:PDosStream; var ExtraInfo:Str10;v:integer);
  74.   far; external 'SWTOOLS1' index 7;
  75. procedure DoneWithInfo(MoreFollowing:PDosStream;v:integer);
  76.   far; external 'SWTOOLS1' index 9;
  77. procedure CreateRegistration(RegFile,name,PassWord:PChar; more:integer;
  78.  var MoreToFollow:PDosStream;v:integer);
  79.   far; external 'SWTOOLS1' index 6;
  80. procedure WriteRegInfo(MoreFollowing:PDosStream; ExtraInfo:PChar;v:integer);
  81.   far; external 'SWTOOLS1' index 8;
  82.  
  83.  
  84.  {The definition for the registration DB}
  85. type
  86.   PRegister=^TRegister;
  87.   TRegister=object(TDialog)
  88.    {The following two methods respond to an id_register and id_quit message
  89.     from Windows, sent when the Register and Quit buttons in this DB are
  90.     pressed.  For the actual values of these, see const section above.}
  91.  
  92.     procedure IDRegister(var msg:TMessage);
  93.       virtual id_first + id_register;
  94.     procedure IDQuit(var msg:TMessage);
  95.       virtual id_first + id_quit;
  96.   end;
  97.  
  98. procedure TRegister.IDRegister(var msg:TMessage);
  99.  {Reaction to the Register button being pressed}
  100.  {To generate a registration number for yourself, use the Scrambler tool.
  101.   For more information, read the help file.}
  102.  
  103.   var
  104.     name,                {Name from the edit}
  105.     ReadReg,             {Reg    "   "    " }
  106.     RealReg,             {Reg the program figured out}
  107.     temp:Str10;          {The approximate temperature in Geneva, Switzerland}
  108.                            {also used as a temporary variable}
  109.     RegFile:PDosStream;  {For disk I/O}
  110.  
  111.   begin
  112.  
  113.     {Retrieve the name and reg number}
  114.     GetDlgItemText(HWindow,id_name,name,11);
  115.     GetDlgItemText(HWindow,id_reg,ReadReg,11);
  116.  
  117.     {Figure out what the Reg # SHOULD have been}
  118.     Scramble(name,pw,RealReg,1);
  119.  
  120.     {Compare it to the one read in}
  121.     if StrIComp(ReadReg,RealReg)<>0
  122.       then begin
  123.        {If they are different,send a message and return to the DB}
  124.         MessageBox(HWindow,'That is not the correct registration code',
  125.           'Bad Reg #',mb_OK);
  126.         exit;
  127.       end;
  128.  
  129.     {Otherwise, create a registration file}
  130.     CreateRegistration(RegPath,name,pw,1,RegFile,1);
  131.  
  132.     {In addition to the name and reg #, send the quest and favorite color}
  133.     GetDlgItemText(HWindow,id_quest,temp,11);
  134.     WriteRegInfo(RegFile,temp,1);
  135.     GetDlgItemText(HWindow,id_FavColor,temp,11);
  136.     WriteRegInfo(RegFile,temp,1);
  137.     {ALWAYS REMEMBER TO CALL THIS WHEN DONE WITH THE REG FILE!}
  138.     DoneWithInfo(RegFile,1);
  139.  
  140.     {Exit the dialog and return 1}
  141.     EndDlg(1);
  142.   end;
  143.  
  144. procedure TRegister.IDQuit(var msg:TMessage);
  145.  {Respond to the Quit button by ending the dialog and returning 0}
  146.   begin
  147.     EndDlg(0);
  148.   end;
  149.  
  150.  
  151.  
  152. {The definition for the TimesUp DB, and for the PleaseReg DB}
  153. {The two DBs are so similar, they only need one definition.}
  154.  
  155. type
  156.   PTimesUp=^TTimesUp;
  157.   TTimesUp=object(TDialog)
  158.     procedure SetUpWindow;
  159.       virtual;
  160.     procedure IDRegister(var msg:TMessage);
  161.       virtual id_first + id_register;
  162.     procedure IDQuit(var msg:TMessage);
  163.       virtual id_first + id_quit;
  164.   end;
  165.  
  166. procedure TTimesUp.SetUpWindow;
  167.  {Changes the static with ID id_DaysLeft to the actual number of days left.}
  168.   var
  169.     DaysLeft:array[0..2] of char;
  170.   begin
  171.     Str(DaysGoneBy(DGBPath,pw,1):2,DaysLeft);
  172.     Str(TrialPeriod-DaysGoneBy(DGBPath,pw,1):2,DaysLeft);
  173.     SetDlgItemText(HWindow,id_daysleft,DaysLeft);
  174.   end;
  175.  
  176. procedure TTimesUp.IDRegister(var msg:TMessage);
  177.  {Reacts to the Register button by creating the Register DB.
  178.   If it returns 1 (i.e. if they registered), returns a 1 and allows
  179.   them to go on with the program.  Otherwise, leaves them with
  180.   this DB again.}
  181.   begin
  182.     if Application^.ExecDialog(new(PRegister,init(@self,'REGISTER')))=1 then EndDlg(1);
  183.   end;
  184.  
  185. procedure TTimesUp.IDQuit(var msg:TMessage);
  186.  {Reacts to the Quit button by closing the DB and returning a 0}
  187.   begin
  188.     EndDlg(0);
  189.   end;
  190.  
  191.  
  192.  {Definition for the main window}
  193. type
  194.   PDemoWin=^TDemoWin;
  195.   TDemoWin=object(TWindow)
  196.  
  197.     constructor init(AParent:PWindowsObject; AName:PChar);
  198.  
  199.     procedure SetUpWindow;
  200.       virtual;
  201.  
  202.     procedure IDScram(var msg:TMessage);
  203.       virtual id_first + id_scram;
  204.     procedure IDDate(var msg:TMessage);
  205.       virtual id_first + id_date;
  206.     procedure IDQuestBtn(var msg:TMessage);
  207.       virtual id_first + id_questBtn;
  208.     procedure IDFavColorBtn(var msg:TMessage);
  209.       virtual id_first + id_FavColorBtn;
  210.     procedure IDHelp(var msg:TMessage);
  211.       virtual id_first + id_help;
  212.   end;
  213.  
  214. constructor TDemoWin.init(AParent:PWindowsObject; AName:PChar);
  215.  {Creates the window and its buttons}
  216.   var
  217.     Button:PButton;
  218.   begin
  219.     TWindow.init(AParent,AName);
  220.     {Each of the following commands causes a button to be created.
  221.     The parameters are as follows: (parent,ID,title,x,y,width,height,default)}
  222.     Button:=new(PButton,init(@self,id_scram,'Scrambler',25,25,100,100,false));
  223.     Button:=new(PButton,init(@self,id_date,'MakeDate',125,125,100,100,false));
  224.     Button:=new(PButton,init(@self,id_help,'Help',225,225,100,100,false));
  225.     Button:=new(PButton,init(@self,id_QuestBtn,'Quest',335,125,100,100,false));
  226.     Button:=new(PButton,init(@self,id_FavColorBtn,'Color',435,25,100,100,false));
  227.   end;
  228.  
  229. procedure TDemoWin.SetUpWindow;
  230.  {This is the part that most uses the SWTools.  Watch closely...}
  231.   var
  232.     RegFile:PDosStream;
  233.     i:integer;
  234.   begin
  235.     TWindow.SetUpWindow;
  236.  
  237.     {Assume they are not registered}
  238.     registered:=0;
  239.     {Check registration file, and pass 1 as the More parameter to ask for
  240.      more info.}
  241.     if CheckRegistration(RegPath,name,pw,1,RegFile,1)=1 then
  242.       begin
  243.        {If CheckRegistration returns 1, they are registered.}
  244.         registered:=1;
  245.  
  246.         {Get more info AND CLOSE REGFILE.}
  247.     GetRegInfo(RegFile,quest,1);
  248.     GetRegInfo(RegFile,FavColor,1);
  249.         DoneWithInfo(RegFile,1);
  250.       end
  251.  
  252.       {If they are not registered...}
  253.       else if DaysGoneBy(DGBPath,pw,1)>TrialPeriod
  254.         {And the trial period is over, execute the TimesUp DB.  It will return
  255.          1 if they register.}
  256.         then if Application^.ExecDialog(new(PTimesUp,init(@self,'TIMESUP')))<>1
  257.           then begin
  258.            {If they don't register, close the window and exit.}
  259.             PostMessage(HWindow,wm_close,0,0);
  260.             exit;
  261.           end
  262.           else registered:=1  {If they do.}
  263.         {If they are NOT registered, and the time limit is NOT up.}
  264.         else if Application^.ExecDialog(new(PTimesUp,init(@self,'PLEASEREG')))=1
  265.           then registered:=1;
  266.  
  267.         {Note that if they register now, their quest and favorite color
  268.          won't be recognized until they quit and load it again.  To
  269.          fix this in your own programs, have the DB notiy you when someone
  270.          registered, or something like that.}
  271.  
  272.   end;
  273.  
  274.  
  275. {The rest of the program just defines the buttons and sets up the app;
  276.  it's pretty self-explanatory, and has very little to do with SWTools.}
  277.  
  278. procedure TDemoWin.IDScram;
  279.   begin
  280.     WinExec('scramble.exe',sw_normal);
  281.   end;
  282.  
  283. procedure TDemoWin.IDDate;
  284.   begin
  285.     WinExec('makedate.exe',sw_normal);
  286.   end;
  287.  
  288. procedure TDemoWin.IDHelp;
  289.   begin
  290.     WinHelp(HWindow,'swdemo.hlp',help_index,0);
  291.   end;
  292.  
  293. procedure TDemoWin.IDQuestBtn;
  294.   begin
  295.     MessageBox(HWindow,quest,name,mb_OK);
  296.   end;
  297.  
  298. procedure TDemoWin.IDFavColorBtn;
  299.   begin
  300.     MessageBox(HWindow,FavColor,name,mb_OK);
  301.   end;
  302.  
  303. type TDemoApp=object(TApplication)
  304.   procedure InitMainWindow;
  305.     virtual;
  306. end;
  307.  
  308. procedure TDemoApp.InitMainWindow;
  309.   begin
  310.     MainWindow:=new(PDemoWin,init(nil,'ShareWare Tools V1.0 Demo'));
  311.   end;
  312.  
  313. var {global}
  314.   DemoApp:TDemoApp;
  315.  
  316. begin {main}
  317.   with DemoApp do begin
  318.     init('SWTOOLSDEMO');
  319.     run;
  320.     done;
  321.   end;
  322. end.
  323.  
  324.                      {Thank you for trying SWTools!}